home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tables / TABTST.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  6.0 KB  |  185 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 1.1
  3. C---------------------------------------------------------
  4. C
  5. C  TABTST - 21 MAR 84
  6. C           TIE TABLES SUPPLEMENTARY LIBRARY
  7. C           TEST PROGRAM
  8. C
  9. C  THIS PROGRAM IS PROVIDED AS A MEANS OF TESTING THE FUNCTIONS
  10. C  PROVIDED IN THE TABLES SUPPLEMENTARY LIBRARY AND AS A MEANS
  11. C  OF GIVING EXAMPLE USES OF SOME OF THE ROUTINES.
  12. C
  13.       PROGRAM TABTST
  14.  
  15.       INTEGER            SIZE, POINTR, JUNK
  16.       PARAMETER (SIZE=1000)
  17.       INTEGER            STRING(134), TABLE(SIZE), TREE(SIZE),
  18.      +                   DATA(2)
  19.       INTEGER            ZTBINT, ZBTINT, ZTBACC, ZBTRST, ZBTNXT
  20.       EXTERNAL           ZINIT, ZQUIT, ERROR, ZMESS, ZIMPLS, SKIP,
  21.      +                   ZTBINT, ZBTINT, ZTBACC, ZBTRST, ZBTNXT
  22.  
  23.       CALL ZINIT
  24.       CALL ZMESS('TABLES TEST PROGRAM.', 1)
  25.       CALL ZIMPLS(STRING)
  26.       CALL ZPTMES(STRING, 1)
  27.       CALL SKIP(1)
  28.       CALL ZMESS('TEST OF TABLES AND BINARY TREES...', 1)
  29. C
  30. C  SET UP A TABLE AND THEN ASK THE USER TO ENTER STRINGS INTO IT
  31. C  IN RANDOM ORDER.
  32. C
  33.       IF(ZTBINT(TABLE, SIZE, 2) .EQ. -1) CALL ERROR(
  34.      +                          'UNABLE TO SET UP TABLE.')
  35.       CALL GTWORD(TABLE)
  36. C
  37. C  NOW ENTER THE TABLE KEYS INTO A BINARY TREE USING IT TO
  38. C  PERFORM A MONKEY PUZZLE SORT INTO LEXICAL ORDER.
  39. C
  40.       IF(ZBTINT(TREE, SIZE, 1, 1) .EQ. -1) CALL ERROR(
  41.      +                          'UNABLE TO SET UP TREE.')
  42.       CALL SORT(TABLE, TREE)
  43. C
  44. C  AN INORDER TRAVERSAL OF THE TREE WILL NOW YIELD THE STRINGS
  45. C  IN LEXICAL ORDER
  46. C
  47.       CALL ZMESS('YOUR STRINGS, IN LEXICAL ORDER, ARE:.',1)
  48.       IF(ZBTRST(TREE) .EQ. -1) CALL ERROR('NOT A TREE.')
  49.  
  50.    10 CONTINUE
  51.       IF(ZBTNXT(POINTR, TREE) .EQ. -100) GO TO 999
  52.       IF(ZTBACC(POINTR, STRING, JUNK, DATA, TABLE) .EQ. -1)
  53.      +  CALL ERROR('INVALID TABLE ENTRY RECOVERY ATTEMPTED.')
  54.       CALL ZPTMES(STRING, 1)
  55.       GO TO 10
  56.  
  57.  999  CONTINUE
  58.       CALL ZQUIT(-2)
  59.       END
  60. C------------------------------------------------------------------
  61. C
  62. C  SORT   - 21 MAR 84
  63. C           TABTST
  64. C
  65. C  SORT TABLE KEYS INTO LEXICAL ORDER
  66. C  THIS IS A MONKEY PUZZLE SORT, EACH NODE OF THE BINARY TREE
  67. C  WILL END UP CONTAINING A POINTER INTO THE TABLE FOR THE
  68. C  APPROPRIATE STRING.
  69. C
  70.       SUBROUTINE SORT(TABLE, TREE)
  71.  
  72.       INTEGER  ENTRYS, JUNK, POINT, CMPPNT, STATUS, DIR
  73.       INTEGER  TABLE(*), TREE(*), STRING(134), COMPAR(134),
  74.      +         DATA(2)
  75.       INTEGER  ZORDER, ZTBTYP, ZTBACC, ZBTADD, ZBTBRA, ZBTTOP
  76.       EXTERNAL ZORDER, ZTBTYP, ZTBACC, ZBTADD, ZBTBRA, ZBTTOP
  77.  
  78. C  FIND OUT HOW MANY TABLE ENTRIES THERE ARE TO BE SORTED
  79.       IF(ZTBTYP(TABLE, JUNK, ENTRYS, JUNK, JUNK) .EQ. -1) CALL
  80.      +   ERROR('ARRAY IS NOT A TABLE.')
  81.  
  82.  
  83. C  LOOP AROUND ENTERING EACH STRING INTO THE TREE. THIS DO LOOP
  84. C  COULD START AT 2 AS THE FIRST ELEMENT HAS ALREADY BEEN PUT
  85. C  INTO THE ROOT NODE DURING INITIALISATION.
  86.       DO 10 POINT = 1, ENTRYS
  87.  
  88. C       GET THE STRING TO BE INSERTED
  89.         IF(ZTBACC(POINT, STRING, JUNK, DATA, TABLE) .EQ. -1)
  90.      +    CALL ERROR('ARRAY IS NOT A TABLE.')
  91.  
  92. C       GO BACK TO THE ROOT AND TRY TO FIND WHERE TO ADD THE NEW
  93. C       STRING. DIR CONTAINS THE FREE SIBLING POSITION INFORMATION
  94. C       FOR THE CURRENT NODE.
  95.         DIR =  ZBTTOP(CMPPNT, TREE)
  96.  
  97. C       THIS INNER LOOP IS EXECUTED REPEATEDLY COMPARING THE NEW
  98. C       STRING WITH THE STRING STORED IN THE CURRENT NODE. IF
  99. C       THE STRINGS ARE EQUAL NO ENTRY IS MADE. IF THE NEW STRING
  100. C       IS GREATER THAN THE STORED STRING TRY TO ADD THE NEW
  101. C       STRING AS A RIGHT SIBLING, IF THE NEW STRING IS LESS THAN
  102. C       THE STORED STRING TRY TO ADD IT AS A LEFT SIBLING. IF IT
  103. C       IS NOT POSSIBLE TO ADD THE NEW STRING (BECAUSE THE REQUIRED
  104. C       SIBLING POINTER IS NOT FREE, THEN MOVE ON TO THE NEXT
  105. C       NODE (TO THE LEFT OR RIGHT AS APPROPRIATE) AND START AGAIN.
  106. C       NOTE THAT STRINGS ARE NOT ACTUALLY STORED IN THE TREE, THE
  107. C       TREE ONLY CONTAINS POINTERS INTO THE TABLE.
  108. C
  109.    20   CONTINUE
  110.         IF(DIR .EQ. -1) CALL ERROR('ARRAY IS NOT A TREE.')
  111.         IF(ZTBACC(CMPPNT, COMPAR, JUNK, DATA, TABLE) .EQ. -1)
  112.      +    CALL ERROR('ARRAY IS NOT A TABLE.')
  113.  
  114.         STATUS = ZORDER(STRING, COMPAR)
  115.         IF(STATUS .EQ. 61) GO TO 10
  116.  
  117.         IF(STATUS .EQ. 60) THEN
  118.           IF((DIR .EQ. 114) .OR. (DIR .EQ. 102)) THEN
  119.             DIR = ZBTBRA(108, CMPPNT, TREE)
  120.             GO TO 20
  121.           ENDIF
  122.           IF(ZBTADD(108, POINT, TREE) .NE. -2) CALL
  123.      +       ERROR('UNABLE TO ADD TO TREE.')
  124.  
  125.         ELSE
  126.           IF((DIR .EQ. 108) .OR. (DIR .EQ. 102)) THEN
  127.             DIR = ZBTBRA(114, CMPPNT, TREE)
  128.             GO TO 20
  129.           ENDIF
  130.           IF(ZBTADD(114, POINT, TREE) .NE. -2) CALL
  131.      +       ERROR('UNABLE TO ADD TO TREE.')
  132.  
  133.         ENDIF
  134.    10 CONTINUE
  135.  
  136.       RETURN
  137.       END
  138. C------------------------------------------------------------------
  139. C
  140. C  GTWORD - 21 MAR 84
  141. C           TABTST
  142. C
  143. C  GET THE WORDS TO BE ENTERED INTO THE TABLE
  144. C
  145.       SUBROUTINE GTWORD(TABLE)
  146.  
  147.       INTEGER  JUNK, ENTRYS, FREE, SIZE
  148.       INTEGER  TABLE(*), DATA(2), STRING(134)
  149.       INTEGER  ZGTCMD, ZTBPUT, ZTBTYP
  150.       EXTERNAL ERROR, ZGTCMD, ZTBPUT, ZMESS, ZTBTYP
  151.  
  152. C  GET STRINGS FROM THE USER AND ENTER THEM INTO THE TABLE,
  153. C  DO NOT ENTER THE SAME WORD MORE THAN ONCE. EACH WORD
  154. C  IS TREATED AS A TABLE ENTRY KEY, THERE ARE TWO DATA
  155. C  VALUES CURRENTLY ASSOCIATED WITH EACH KEY, THE FIRST
  156. C  EQUALS THE STRING LENGTH.
  157.  
  158.       DATA(2) = 0
  159.  
  160.    10 CONTINUE
  161.  
  162.         CALL ZMESS('ENTER WORD FOR THE TABLE:.', 1)
  163.         IF(ZTBTYP(TABLE, JUNK, ENTRYS, FREE, JUNK) .EQ. -1) CALL
  164.      +     ERROR('ARRAY IS NOT A TABLE.')
  165.  
  166.         SIZE = ZGTCMD(STRING, 0)
  167.         DATA(1) = SIZE
  168.         IF((SIZE .EQ.0) .OR. (SIZE .EQ. -100)) GO TO 999
  169.         SIZE = SIZE + 1
  170.         IF(ZTBPUT(STRING, SIZE, DATA, TABLE) .EQ. -100) THEN
  171.           CALL ZMESS('TABLE IS TOO FULL.', 1)
  172.           GO TO 999
  173.         ENDIF
  174.  
  175.       GO TO 10
  176.  
  177.   999 CONTINUE
  178.       IF(ENTRYS .EQ. 0) CALL ERROR('NO ENTRIES MADE.')
  179.       CALL PUTDEC(ENTRYS, 1)
  180.       CALL ZMESS(' UNIQUE ENTRIES MADE.', 1)
  181.  
  182.       RETURN
  183.       END
  184.  
  185.